home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Runtime (.scm & .s) / mac_ext.scm < prev   
Encoding:
Text File  |  1995-03-15  |  23.4 KB  |  652 lines  |  [TEXT/gamI]
  1. (##declare
  2.   (multilisp)
  3.   (extended-bindings)
  4.   (not safe)
  5.   (not autotouch)
  6.   (block)
  7.   (fixnum)
  8.   (not intr-checks))
  9.  
  10. ;------------------------------------------------------------------------------
  11.  
  12. ; Utilities
  13.  
  14. (define (mac#unsigned16->signed16 x) ; ##vector16-ref returns 0..65535
  15.   (##fixnum.- (##fixnum.modulo (##fixnum.+ x 32768) 65536) 32768))
  16.  
  17. ; Macintosh events
  18.  
  19. (define (mac#event-what ev)
  20.   (##vector16-ref ev 0))
  21. (define (mac#event-message ev)
  22.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 1) 65536) (##vector16-ref ev 2)))
  23. (define (mac#event-when ev)
  24.   (##fixnum.+ (##fixnum.* (##vector16-ref ev 3) 65536) (##vector16-ref ev 4)))
  25. (define (mac#event-where ev)
  26.   (mac#point (##vector16-ref ev 5) (##vector16-ref ev 6)))
  27. (define (mac#event-modifiers ev)
  28.   (##vector16-ref ev 7))
  29.  
  30. (define (mac#modifiers-button? modifiers)
  31.   (##fixnum.zero? (##fixnum.logand modifiers 128)))
  32.  
  33. (define (mac#modifiers-command? modifiers)
  34.   (##not (##fixnum.zero? (##fixnum.logand modifiers 256))))
  35.  
  36. (define (mac#modifiers-shift? modifiers)
  37.   (##not (##fixnum.zero? (##fixnum.logand modifiers 512))))
  38.  
  39. (define (mac#modifiers-alphalock? modifiers)
  40.   (##not (##fixnum.zero? (##fixnum.logand modifiers 1024))))
  41.  
  42. (define (mac#modifiers-option? modifiers)
  43.   (##not (##fixnum.zero? (##fixnum.logand modifiers 2048))))
  44.  
  45. ; Quickdraw points
  46.  
  47. (define (mac#point v h)
  48.   (let ((p (##make-vector16 2 0)))
  49.     (##vector16-set! p 0 v)
  50.     (##vector16-set! p 1 h)
  51.     p))
  52.  
  53. (define (mac#point-v r) (mac#unsigned16->signed16 (##vector16-ref r 0)))
  54. (define (mac#point-h r) (mac#unsigned16->signed16 (##vector16-ref r 1)))
  55. (define (mac#point-v-set! r x) (##vector16-set! r 0 x))
  56. (define (mac#point-h-set! r x) (##vector16-set! r 1 x))
  57.  
  58. ; Quickdraw rectangles
  59.  
  60. (define (mac#rect top left bottom right)
  61.   (let ((r (##make-vector16 4 0)))
  62.     (##vector16-set! r 0 top)
  63.     (##vector16-set! r 1 left)
  64.     (##vector16-set! r 2 bottom)
  65.     (##vector16-set! r 3 right)
  66.     r))
  67.  
  68. (define (mac#rect-top r)    (mac#unsigned16->signed16 (##vector16-ref r 0)))
  69. (define (mac#rect-left r)   (mac#unsigned16->signed16 (##vector16-ref r 1)))
  70. (define (mac#rect-bottom r) (mac#unsigned16->signed16 (##vector16-ref r 2)))
  71. (define (mac#rect-right r)  (mac#unsigned16->signed16 (##vector16-ref r 3)))
  72. (define (mac#rect-top-set! r x)    (##vector16-set! r 0 x))
  73. (define (mac#rect-left-set! r x)   (##vector16-set! r 1 x))
  74. (define (mac#rect-bottom-set! r x) (##vector16-set! r 2 x))
  75. (define (mac#rect-right-set! r x)  (##vector16-set! r 3 x))
  76.  
  77. ; Quickdraw procedures
  78.  
  79. ;Color stuff
  80.  
  81. (define (mac#newcwindow bounds title visible procid behind goaway)
  82.   (mac_#newcwindow bounds title visible procid behind goaway))
  83.  
  84. (define (mac#getnewcwindow windowid behind)
  85.   (mac_#getnewcwindow windowid behind))
  86.  
  87. (define (mac#rgbforecolor red green blue)
  88.   (mac_#rgbforecolor red green blue))
  89.  
  90. (define (mac#rgbbackcolor red green blue)
  91.   (mac_#rgbbackcolor red green blue))
  92.  
  93. ;Regular Quickdraw
  94.  
  95. (define (mac#newwindow bounds title visible procid behind goaway)
  96.   (mac_#newwindow bounds title visible procid behind goaway))
  97.  
  98. (define (mac#getnewwindow windowid behind)
  99.   (mac_#getnewwindow windowid behind))
  100.  
  101. (define (mac#disposewindow w)
  102.   (mac_#disposewindow w))
  103.  
  104. (define (mac#selectwindow w)
  105.   (mac_#selectwindow w))
  106.  
  107. (define (mac#hidewindow w)
  108.   (mac_#hidewindow w))
  109.  
  110. (define (mac#showwindow w)
  111.   (mac_#showwindow w))
  112.  
  113. (define (mac#frontwindow)
  114.   (mac_#frontwindow))
  115.  
  116. (define (mac#bringtofront w)
  117.   (mac_#bringtofront w))
  118.  
  119. (define (mac#showhide w flag)
  120.   (mac_#showhide w flag))
  121.  
  122. (define (mac#hilitewindow w flag)
  123.   (mac_#hilitewindow w flag))
  124.  
  125. (define (mac#findwindow pt w-cell)
  126.   (mac_#findwindow pt w-cell))
  127.  
  128. (define (mac#trackgoaway w pt)
  129.   (mac_#trackgoaway w pt))
  130.  
  131. (define (mac#dragwindow w pt r)
  132.   (mac_#dragwindow w pt r))
  133.  
  134. (define (mac#invalrect port r)
  135.   (mac_#invalrect port r))
  136.  
  137. (define (mac#beginupdate w)
  138.   (mac_#beginupdate w))
  139.  
  140. (define (mac#endupdate w)
  141.   (mac_#endupdate w))
  142.  
  143. (define (mac#openport port) (mac_#openport port))
  144. (define (mac#initport port) (mac_#initport port))
  145. (define (mac#closeport port) (mac_#closeport port))
  146. (define (mac#setport port) (mac_#setport port))
  147. (define (mac#getport) (mac_#getport))
  148. (define (mac#setorigin port h v) (mac_#setport port h v))
  149. (define (mac#backpat port pat) (mac_#backpat port pat))
  150. (define (mac#hidecursor) (mac_#hidecursor))
  151. (define (mac#showcursor) (mac_#showcursor))
  152. ;;; New cursor functions
  153. (define (mac#getcursor cursorid) (mac_#getcursor cursorid))
  154. (define (mac#getccursor cursorid) (mac_#getccursor cursorid))
  155. (define (mac#setcursor cursorhndl) (mac_#setcursor cursorhndl))
  156. (define (mac#setccursor cursorhndl) (mac_#setccursor cursorhndl))
  157. (define (mac#disposeccursor cursorhndl) (mac_#disposeccursor cursorhndl))
  158. ;(define (mac#rotatecursor cursorhndl) (mac_#rotatecursor cursorhndl))
  159. ;(define (mac#spincursor cursorhndl) (mac_#spincursor cursorhndl))
  160.  
  161. (define (mac#pensize port width height) (mac_#pensize port width height))
  162. (define (mac#penmode port mode) (mac_#penmode port mode))
  163. (define (mac#penpat port pat) (mac_#penpat port pat))
  164. (define (mac#pennormal port) (mac_#pennormal port))
  165. (define (mac#moveto port h v) (mac_#moveto port h v))
  166. (define (mac#move port dh dv) (mac_#move port dh dv))
  167. (define (mac#lineto port h v) (mac_#lineto port h v))
  168. (define (mac#line port dh dv) (mac_#line port dh dv))
  169. (define (mac#textfont port font) (mac_#textfont port font))
  170. (define (mac#textface port face) (mac_#textface port face))
  171. (define (mac#textmode port mode) (mac_#textmode port mode))
  172. (define (mac#textsize port size) (mac_#textsize port size))
  173. (define (mac#spaceextra port extra) (mac_#spaceextra port extra))
  174. (define (mac#drawchar port ch) (mac_#drawchar port ch))
  175. (define (mac#drawstring port s) (mac_#drawstring port s))
  176. (define (mac#drawtext port textbuf firstbyte bytecount)
  177.   (mac_#drawtext port textbuf firstbyte bytecount))
  178. (define (mac#charwidth port ch) (mac_#charwidth port ch))
  179. (define (mac#stringwidth port s) (mac_#stringwidth port s))
  180. (define (mac#textwidth port textbuf firstbyte bytecount)
  181.   (mac_#textwidth port textbuf firstbyte bytecount))
  182. (define (mac#localtoglobal port pt) (mac_#localtoglobal port pt))
  183. (define (mac#globaltolocal port pt) (mac_#globaltolocal port pt))
  184. (define (mac#framerect port r) (mac_#framerect port r))
  185. (define (mac#paintrect port r) (mac_#paintrect port r))
  186. (define (mac#eraserect port r) (mac_#eraserect port r))
  187. (define (mac#invertrect port r) (mac_#invertrect port r))
  188. (define (mac#fillrect port r pat) (mac_#fillrect port r pat))
  189. (define (mac#frameroundrect port r ovwd ovht)
  190.   (mac_#frameroundrect port r ovwd ovht))
  191. (define (mac#paintroundrect port r ovwd ovht)
  192.   (mac_#paintroundrect port r ovwd ovht))
  193. (define (mac#eraseroundrect port r ovwd ovht)
  194.   (mac_#eraseroundrect port r ovwd ovht))
  195. (define (mac#invertroundrect port r ovwd ovht)
  196.   (mac_#invertroundrect port r ovwd ovht))
  197. (define (mac#fillroundrect port r ovwd ovht pat)
  198.   (mac_#fillroundrect port r ovwd ovht pat))
  199. (define (mac#frameoval port r) (mac_#frameoval port r))
  200. (define (mac#paintoval port r) (mac_#paintoval port r))
  201. (define (mac#eraseoval port r) (mac_#eraseoval port r))
  202. (define (mac#invertoval port r) (mac_#invertoval port r))
  203. (define (mac#filloval port r pat) (mac_#filloval port r pat))
  204. (define (mac#framearc port r startangle arcangle)
  205.   (mac_#framearc port r startangle arcangle))
  206. (define (mac#paintarc port r startangle arcangle)
  207.   (mac_#paintarc port r startangle arcangle))
  208. (define (mac#erasearc port r startangle arcangle)
  209.   (mac_#erasearc port r startangle arcangle))
  210. (define (mac#invertarc port r startangle arcangle)
  211.   (mac_#invertarc port r startangle arcangle))
  212. (define (mac#fillarc port r startangle arcangle pat)
  213.   (mac_#fillarc port r startangle arcangle pat))
  214.  
  215. (define (mac#openpoly) (mac_#openpoly))
  216. (define (mac#closepoly) (mac_#closepoly))
  217. (define (mac#offsetpoly poly h v) (mac_#offsetpoly poly h v))
  218. (define (mac#killpoly poly) (mac_#killpoly poly))
  219. (define (mac#framepoly poly) (mac_#framepoly poly))
  220. (define (mac#paintpoly poly) (mac_#paintpoly poly))
  221. (define (mac#fillpoly poly pat) (mac_#fillpoly poly pat))
  222. (define (mac#erasepoly poly) (mac_#erasepoly poly))
  223. (define (mac#invertpoly poly) (mac_#invertpoly poly))
  224.  
  225. ; Menus
  226.  
  227. (define (mac#menuselection selection) #f)
  228.  
  229. (define (mac#newmenu menuid str) (mac_#newmenu menuid str))
  230. (define (mac#getmenu resourceid) (mac_#getmenu resourceid))
  231. (define (mac#disposemenu themenu) (mac_#disposemenu themenu))
  232. (define (mac#appendmenu themenu str) (mac_#appendmenu themenu str))
  233. (define (mac#addresmenu themenu thetype) (mac_#addresmenu themenu thetype))
  234. (define (mac#insertresmenu themenu thetype afteritem)
  235.   (mac_#insertresmenu themenu thetype afteritem))
  236. (define (mac#insertmenu themenu beforeid) (mac_#insertmenu themenu beforeid))
  237. (define (mac#drawmenubar) (mac_#drawmenubar))
  238. (define (mac#deletemenu menuid) (mac_#deletemenu menuid))
  239. (define (mac#clearmenubar) (mac_#clearmenubar))
  240. (define (mac#getnewmbar menubarid) (mac_#getnewmbar menubarid))
  241. (define (mac#getmenubar) (mac_#getmenubar))
  242. (define (mac#setmenubar menulist) (mac_#setmenubar menulist))
  243. (define (mac#menuselect p) (mac_#menuselect p))
  244. (define (mac#menukey ch) (mac_#menukey ch))
  245. (define (mac#hilitemenu menuid) (mac_#hilitemenu menuid))
  246. (define (mac#disableitem themenu item) (mac_#disableitem themenu item))
  247. (define (mac#enableitem themenu item) (mac_#enableitem themenu item))
  248. (define (mac#checkitem themenu item checked) (mac_#checkitem  themenu item checked))
  249. (define (mac#getmhandle menuid) (mac_#getmhandle menuid))
  250.  
  251. ; Standard file get/put
  252.  
  253. (define (mac#sfgetfile (prompt "") (ftypes "TEXT"))
  254.   (mac_#sfgetfile (##make-string 256 #\space) prompt ftypes))
  255.  
  256. (define (mac#sfputfile (prompt "") (default ""))
  257.   (mac_#sfputfile (##make-string 256 #\space) prompt default))
  258.  
  259. ; Other procedures
  260.  
  261. (define (mac#getmouse pt) (mac_#getmouse pt))
  262. (define (mac#stilldown)
  263.   (if (##fixnum.= (mac_#stilldown) 0)
  264.     #f #t))
  265. (define (mac#button) (mac_#button))
  266. (define (mac#tickcount) (mac_#tickcount))
  267. (define (mac#delay duration) (mac_#delay duration))
  268. (define (mac#sysbeep duration) (mac_#sysbeep duration))
  269. (define (mac#seteventmask themask) (mac_#seteventmask themask))
  270.  
  271. (define (mac#jimsfunc) (mac_#jimsfunc))
  272. ;vector msgID = ID of HLE to send, vector buffer = data buffer
  273. (define (mac#sendhle msgID buffer) (mac_#sendhle msgID buffer))
  274. ;vector msgID = ID of HLE returned
  275. (define (mac#awaithle msgID) (mac_#awaithle msgID))
  276. ;vector msgID = ID of HLE returned, buffer = the data
  277. (define (mac#waitgethle msgID buffer) (mac_#waitgethle msgID buffer))
  278. ;vector buffer = data buffer
  279. (define (mac#gethledata buffer) (mac_#gethledata buffer))
  280.  
  281. (define (mac#loadpictfile file) (mac_#loadpictfile file))
  282. (define (mac#drawpict pict port) (mac_#drawpict pict port))
  283. (define (mac#loadrespict resid) (mac_#loadrespict resid))
  284. (define (mac#convertpict pict t l b r) (mac_#convertpict pict t l b r))
  285. (define (mac#releaseresource pict) (mac_#releaseresource pict))
  286. (define (mac#setwindowpic port pict) (mac_#setwindowpic port pict))
  287. (define (mac#drawpicture pict) (mac_#drawpict pict))
  288.  
  289. (define (mac#bringtofront w) (mac_#bringtofront w))
  290.  
  291. (define (mac#peek8 ptr) (mac_#peek8 ptr))
  292. (define (mac#poke8 ptr val) (mac_#poke8 ptr val))
  293. (define (mac#peek16 ptr) (mac_#peek16 ptr))
  294. (define (mac#poke16 ptr val) (mac_#poke16 ptr val))
  295. (define (mac#peek32 ptr) (mac_#peek32 ptr))
  296. (define (mac#poke32 ptr val) (mac_#poke32 ptr val))
  297.  
  298. ;(define (mac#filemodate file) (mac_#filemodate file))
  299.  
  300. (define (mac#filemodate file)
  301.   (let ((r (##make-vector16 16 0)))
  302.     (mac_#filemodate file r)
  303.     (+ (* 65536 (##vector16-ref r 0)) (##vector16-ref r 1))))
  304.  
  305. (define (mac#flashmenubar menuid) (mac_#flashmenubar menuid))
  306. ; Editor windows
  307.  
  308. (define (mac#edit filename (line 0) (char 0))
  309.   (mac_#edit filename line char))
  310.  
  311. ; Text windows
  312.  
  313. (define (open-text-window name)
  314.   (if (##string? name)
  315.     (##open-input-output-file
  316.       (##string-append (##make-string 1 (##integer->char 2)) name))
  317.     #f))
  318.  
  319. ; Online help
  320.  
  321. (define (mac#help name)
  322.   (mac_#help name))
  323.  
  324. (define (help (name ""))
  325.   (cond ((##string? name) (mac#help name))
  326.         ((##symbol? name) (mac#help (##symbol->string name)))
  327.         (else             (mac#help ""))))
  328.  
  329. ;------------------------------------------------------------------------------
  330.  
  331. ; Window manager
  332.  
  333. (define mac#window-bindings (##cons #f '()))
  334.  
  335. (define mac#window-drag-bounds (mac#rect 0 0 32000 32000))
  336.  
  337. (define (mac#window-bind w wind)
  338.   (let ((wind-struct (##cons wind (##cons #f (##make-queue)))))
  339.     (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  340.       (if (##pair? pres)
  341.         (let ((x (##car pres)))
  342.           (if (##fixnum.= (##car x) w)
  343.             (##set-cdr! x wind-struct)
  344.            (loop pres (##cdr pres))))
  345.         (##set-cdr! prev (##cons (##cons w wind-struct) '()))))))
  346.  
  347. (define (mac#window-unbind w)
  348.   (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  349.     (if (##pair? pres)
  350.       (let ((x (##car pres)))
  351.         (if (##fixnum.= (##car x) w)
  352.           (##set-cdr! prev (##cdr pres))
  353.           (loop pres (##cdr pres))))
  354.       #f)))
  355.  
  356. (define (mac#window-lookup w)
  357.   (let loop ((prev mac#window-bindings) (pres (##cdr mac#window-bindings)))
  358.     (if (##pair? pres)
  359.       (let ((x (##car pres)))
  360.         (if (##fixnum.= (##car x) w)
  361.           (##cdr x)
  362.           (loop pres (##cdr pres))))
  363.       #f)))
  364.  
  365. (define (mac#window-reset w)
  366.   (let ((wind-struct (mac#window-lookup w)))
  367.     (if wind-struct
  368.       (##set-cdr! wind-struct (##cons #f (##make-queue))))
  369.     #f))
  370.  
  371. (define (mac#window-handle-event wind-struct event)
  372.  
  373.   (define (send-window-event wind event)
  374.     (let ((what (mac#event-what event)))
  375.       (cond ((##fixnum.= what 0)
  376.              ((wind 'GOAWAY)))
  377.             ((or (##fixnum.= what 1)
  378.                  (##fixnum.= what 2))
  379.              ((wind (cond ((##fixnum.= what 1) 'MOUSEDOWN)
  380.                           (else                'MOUSEUP)))
  381.               (mac#event-where event)
  382.               (mac#event-modifiers event)))
  383.             ((or (##fixnum.= what 3)
  384.                  (##fixnum.= what 4)
  385.                  (##fixnum.= what 5))
  386.              ((wind (cond ((##fixnum.= what 3) 'KEYDOWN)
  387.                           ((##fixnum.= what 4) 'KEYUP)
  388.                           (else                'AUTOKEY)))
  389.               (##type-cast (##fixnum.logand (mac#event-message event) 255) 7)
  390.               (mac#event-modifiers event)))
  391.             ((##fixnum.= what 6)
  392.              ((wind 'UPDATE)))
  393.             ((##fixnum.= what 8)
  394.              (if (##fixnum.odd? (mac#event-modifiers event))
  395.                ((wind 'ACTIVATE))
  396.                ((wind 'DEACTIVATE)))))))
  397.  
  398.   (let* ((wind (##car wind-struct))
  399.          (sequentializer (##cdr wind-struct))
  400.          (pending-events (##cdr sequentializer)))
  401.     (if (##car sequentializer)
  402.  
  403.       (##queue-put! pending-events event) ; queue event on window
  404.  
  405.       (begin
  406.         (##set-car! sequentializer #t)
  407.         (future ; spawn a task to handle the window's events
  408.           (let loop ((event event))
  409.             (send-window-event wind event)
  410.             (let ((x (##queue-get! pending-events)))
  411.               (if x
  412.                 (loop (##car x))
  413.                 (##set-car! sequentializer #f))))))))
  414.  
  415.   #f)
  416.  
  417. (define (mac#event-handler event)
  418.  
  419.   ; IMPORTANT NOTE:
  420.   ;
  421.   ; Event handling must be done atomically to preserve the ordering
  422.   ; of the events.  Events are generated and handled in bursts every time
  423.   ; there is a timer interrupt (roughly 10 times a second).  If interrupts
  424.   ; were enabled and the handling of an event took too long (> 1/10 sec),
  425.   ; for example if a garbage collection occurs in the middle of processing
  426.   ; or there is a user interrupt, then it would be possible for the handling
  427.   ; of a later event to start and complete before the processing of the
  428.   ; original event is finished.
  429.   ;
  430.   ; To solve this problem, this procedure is written so that it
  431.   ; does not cons and does not allow interrupts (interrupt checks are
  432.   ; not generated inside the procedure and no procedure which might check
  433.   ; interrupts is called).  To prevent consing this procedure mutates
  434.   ; constants (this is OK in Gambit even though it is an error in IEEE-Scheme).
  435.   ;
  436.   ; In addition, each window has an associated queue of pending events.
  437.   ; Only one event per window can be processed at a time.  If an event is
  438.   ; generated for a particular window and that window is still processing a
  439.   ; previous event, the event is put on the window's queue.  When the
  440.   ; processing of an event ends, the next event on the queue is processed (if
  441.   ; there is one).  Unfortunately, this means that if the processing of an
  442.   ; event is aborted (due to an error or user interrupt), the window will
  443.   ; not accept any new events.  The procedure call (mac#window-reset wind)
  444.   ; can be used to reenable the processing of new events on the window 'wind'.
  445.   ;
  446.   ; The processing of a window's events is done in a task (created by a
  447.   ; future).  This means that multiple windows may be "running" concurrently
  448.   ; with the main program.  This introduces the usual multitasking problems.
  449.   ; Shared data structures should be protected with semaphores to guarantee
  450.   ; that only one task is accessing them at any given point in time.
  451.  
  452.   (let* ((what (##vector16-ref event 0))
  453.          (message (##fixnum.+ (##fixnum.* (##vector16-ref event 1) 65536)
  454.                               (##vector16-ref event 2)))
  455.          (w-cell '(0)) ; these two constants get mutated (to avoid consing)
  456.          (where "1234"))
  457.     (cond ((or (##fixnum.= what 1)  ; mousedown event
  458.                (##fixnum.= what 2)) ; mouseup event
  459.            (##vector16-set! where 0 (##vector16-ref event 5)) ; mutate 'where'
  460.            (##vector16-set! where 1 (##vector16-ref event 6))
  461.            (let* ((in (mac#findwindow where w-cell)) ; mutate 'w-cell'
  462.                   (w (##car w-cell))
  463.                   (wind-struct (mac#window-lookup w)))
  464.              (if wind-struct
  465.                (cond ((##fixnum.= in 3) ; incontent
  466.                       (if (##fixnum.= w (mac#frontwindow))
  467.                         (begin
  468.                           (mac#globaltolocal w where)
  469.                           (##vector16-set! event 5 (##vector16-ref where 0))
  470.                           (##vector16-set! event 6 (##vector16-ref where 1))
  471.                           (mac#window-handle-event wind-struct event))
  472.                         (begin
  473.                           (if (##fixnum.= what 1) (mac#selectwindow w))
  474.                           #f)))
  475.                      ((##fixnum.= in 4) ; indrag
  476.                       (if (##fixnum.= what 1)
  477.                         (mac#dragwindow w where mac#window-drag-bounds))
  478.                       #f)
  479.                      ((##fixnum.= in 6) ; ingoaway
  480.                       (if (and (##fixnum.= what 1) (mac#trackgoaway w where))
  481.                         (begin
  482.                           (##vector16-set! event 0 0)
  483.                           (mac#window-handle-event wind-struct event))
  484.                         #f)))
  485.                (##os-handle-event event))))
  486.           ((or (##fixnum.= what 3)  ; keydown event
  487.                (##fixnum.= what 4)  ; keyup event
  488.                (##fixnum.= what 5)) ; autokey event
  489.            (if (mac#modifiers-command? (##vector16-ref event 7)) ; command?
  490.              (##os-handle-event event)
  491.              (let* ((w (mac#frontwindow))
  492.                     (wind-struct (mac#window-lookup w)))
  493.                (if wind-struct
  494.                  (mac#window-handle-event wind-struct event)
  495.                  (##os-handle-event event)))))
  496.           ((##fixnum.= what 6) ; update event
  497.            (let ((wind-struct (mac#window-lookup message)))
  498.              (if wind-struct
  499.                (begin
  500.                  (mac#beginupdate message) ; discard update region
  501.                  (mac#endupdate message)
  502.                  (mac#window-handle-event wind-struct event))
  503.                (##os-handle-event event))))
  504.           ((##fixnum.= what 8) ; activate and deactivate events
  505.            (let ((wind-struct (mac#window-lookup message)))
  506.              (if wind-struct
  507.                (mac#window-handle-event wind-struct event)
  508.                (##os-handle-event event))))
  509.           (else
  510.            (##os-handle-event event)))))
  511.  
  512. (set! ##handle-os-event mac#event-handler)
  513.  
  514. ;------------------------------------------------------------------------------
  515.  
  516. ; Drawing window
  517.  
  518. (define clear-graphics #f)
  519. (define position-pen #f)
  520. (define draw-line-to #f)
  521. (define draw-point #f)
  522. (define clear-point #f)
  523. (define graphics-text #f)
  524.  
  525. (let ()
  526.  
  527.   (define top     40)
  528.   (define right   510)
  529.   (define y-max   200.) ; must be inexact (flonum)
  530.   (define x-max   200.) ;   "        "
  531.   (define scaling .5)   ;   "        "
  532.   (define visible? #f)
  533.  
  534.   (define (cx x)
  535.     (##flonum.->fixnum
  536.       (##flonum.* (##flonum.+ x-max (##real-part (##exact->inexact x)))
  537.                   scaling)))
  538.  
  539.   (define (cy y)
  540.     (##flonum.->fixnum
  541.       (##flonum.* (##flonum.- y-max (##real-part (##exact->inexact y)))
  542.                   scaling)))
  543.  
  544.   (let* ((clear-rect (mac#rect -32000 -32000 32000 32000))
  545.          (width (##flonum.->fixnum (##flonum.* (##flonum.* 2. x-max) scaling)))
  546.          (height (##flonum.->fixnum (##flonum.* (##flonum.* 2. y-max) scaling)))
  547.          (w (mac#newwindow
  548.               (mac#rect top (##fixnum.- right width) (##fixnum.+ top height) right)
  549.               "Drawing" visible? 19 (if visible? -1 0) #t))
  550.          (head (##cons #f '()))
  551.          (tail head)
  552.          (pen-x0 (cx 0))
  553.          (pen-y0 (cy 0))
  554.          (pen-x #f)
  555.          (pen-y #f))
  556.  
  557.     (define (wind msg)
  558.       (cond ((##eq? msg 'GOAWAY) goaway)
  559.             ((##eq? msg 'UPDATE) update)
  560.             (else                ##list))) ; discard other events
  561.  
  562.     (define (goaway)
  563.       (mac#hidewindow w))
  564.  
  565.     (define (update)
  566.       (set! pen-x pen-x0)
  567.       (set! pen-y pen-y0)
  568.       (let loop ((l (##cdr head)))
  569.         (if (##pair? l)
  570.           (begin ((##car l)) (loop (##cdr l))))))
  571.  
  572.     (define (show)
  573.       (if (##fixnum.zero? (mac#peek8 (##fixnum.+ w 110))) ; not visible?
  574.         (begin
  575.           (mac#showwindow w)      ; make it visible
  576.           (mac#selectwindow w)))) ; and in front of all other windows
  577.  
  578.     (define (clear)
  579.       (##set-cdr! head '())
  580.       (set! tail head)
  581.       (mac#eraserect w clear-rect))
  582.  
  583.     (define (add action)
  584.       (let ((x (##cons action '())))
  585.         (##set-cdr! tail x)
  586.         (set! tail x)
  587.         (show)
  588.         (action)))
  589.  
  590.     (define (init)
  591.       (set! pen-x pen-x0)
  592.       (set! pen-y pen-y0)
  593.       (clear))
  594.  
  595.     (define (make-position-pen x y)
  596.       (lambda ()
  597.         (set! pen-x x)
  598.         (set! pen-y y)))
  599.  
  600.     (define (make-draw-line-to x y)
  601.       (lambda ()
  602.         (mac#moveto w pen-x pen-y)
  603.         (mac#lineto w x y)
  604.         (set! pen-x x)
  605.         (set! pen-y y)))
  606.  
  607.     (define (make-draw-point x y)
  608.       (lambda ()
  609.         (mac#moveto w x y)
  610.         (mac#lineto w x y)))
  611.  
  612.     (define (make-clear-point x y)
  613.       (lambda ()
  614.         (mac#penmode w 11) ; patBic
  615.         (mac#moveto w x y)
  616.         (mac#lineto w x y)
  617.         (mac#penmode w 8))) ; patCopy
  618.  
  619.     (define (make-graphics-text text x y)
  620.       (lambda ()
  621.         (mac#moveto w x y)
  622.         (mac#drawstring w text)))
  623.  
  624.     (set! clear-graphics
  625.       (lambda () (show) (clear) #f))
  626.  
  627.     (set! position-pen
  628.       (lambda (x y) (add (make-position-pen (cx x) (cy y))) #f))
  629.  
  630.     (set! draw-line-to
  631.       (lambda (x y) (add (make-draw-line-to (cx x) (cy y))) #f))
  632.  
  633.     (set! draw-point
  634.       (lambda (x y) (add (make-draw-point (cx x) (cy y))) #f))
  635.  
  636.     (set! clear-point
  637.       (lambda (x y) (add (make-clear-point (cx x) (cy y))) #f))
  638.  
  639.     (set! graphics-text
  640.       (lambda (text x y)
  641.         (if (##string? text) (add (make-graphics-text text (cx x) (cy y))))
  642.         #f))
  643.  
  644.     (mac#textfont w 4) ; monaco
  645.     (mac#textsize w 9)
  646.  
  647.     (init)
  648.  
  649.     (mac#window-bind w wind)))
  650.  
  651. ;------------------------------------------------------------------------------
  652.